Visual Basic Source Code

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / yatzys_1 / yatzy.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1998-10-22 | 24.3 KB | 731 lines

VERSION 5.00 Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX" Begin VB.Form frmYatzy BackColor = &H00C0FFFF& BorderStyle = 1 'Fixed Single Caption = "Yatzy" ClientHeight = 5340 ClientLeft = 90 ClientTop = 1380 ClientWidth = 9090 Icon = "yatzy.frx":0000 LinkTopic = "Form1" MaxButton = 0 'False PaletteMode = 1 'UseZOrder ScaleHeight = 356 ScaleMode = 3 'Pixel ScaleWidth = 606 StartUpPosition = 2 'CenterScreen Begin MSFlexGridLib.MSFlexGrid grdScoreBoard Height = 4665 Left = 240 TabIndex = 0 Top = 240 Width = 5085 _ExtentX = 8969 _ExtentY = 8229 _Version = 65541 Rows = 19 Cols = 11 FixedRows = 0 FixedCols = 0 BackColorBkg = 12632256 Redraw = -1 'True Enabled = -1 'True HighLight = 0 GridLinesFixed = 1 ScrollBars = 0 End Begin VB.PictureBox picDice Appearance = 0 'Flat BackColor = &H00C0FFFF& BorderStyle = 0 'None ForeColor = &H80000008& Height = 480 Index = 4 Left = 7320 ScaleHeight = 480 ScaleWidth = 480 TabIndex = 6 Top = 3240 Width = 480 End Begin VB.PictureBox picDice Appearance = 0 'Flat BackColor = &H00C0FFFF& BorderStyle = 0 'None ForeColor = &H80000008& Height = 480 Index = 3 Left = 6600 ScaleHeight = 480 ScaleWidth = 480 TabIndex = 5 Top = 3240 Width = 480 End Begin VB.PictureBox picDice Appearance = 0 'Flat BackColor = &H00C0FFFF& BorderStyle = 0 'None ForeColor = &H80000008& Height = 480 Index = 2 Left = 7680 ScaleHeight = 480 ScaleWidth = 480 TabIndex = 4 Top = 2520 Width = 480 End Begin VB.PictureBox picDice Appearance = 0 'Flat BackColor = &H00C0FFFF& BorderStyle = 0 'None ForeColor = &H80000008& Height = 480 Index = 1 Left = 6960 ScaleHeight = 480 ScaleWidth = 480 TabIndex = 3 Top = 2520 Width = 480 End Begin VB.PictureBox picDice Appearance = 0 'Flat BackColor = &H00C0FFFF& BorderStyle = 0 'None DrawStyle = 5 'Transparent FillStyle = 0 'Solid ForeColor = &H00FFFFFF& Height = 480 Index = 0 Left = 6240 ScaleHeight = 480 ScaleWidth = 480 TabIndex = 2 Top = 2520 Width = 480 End Begin VB.Timer Timer1 Enabled = 0 'False Interval = 50 Left = 5520 Top = 4320 End Begin VB.CommandButton cmdHitMe Height = 735 Left = 6120 TabIndex = 1 Top = 4080 Width = 2175 End Begin VB.Image imgNumber Appearance = 0 'Flat Height = 480 Index = 5 Left = 8400 Picture = "yatzy.frx":030A Top = 600 Width = 480 Visible = 0 'False End Begin VB.Image imgNumber Appearance = 0 'Flat Height = 480 Index = 4 Left = 7800 Picture = "yatzy.frx":03DD Top = 600 Width = 480 Visible = 0 'False End Begin VB.Image imgNumber Appearance = 0 'Flat Height = 480 Index = 3 Left = 7200 Picture = "yatzy.frx":04AC Top = 600 Width = 480 Visible = 0 'False End Begin VB.Image imgNumber Appearance = 0 'Flat Height = 480 Index = 2 Left = 6600 Picture = "yatzy.frx":0577 Top = 600 Width = 480 Visible = 0 'False End Begin VB.Image imgNumber Appearance = 0 'Flat Height = 480 Index = 1 Left = 6000 Picture = "yatzy.frx":063B Top = 600 Width = 480 Visible = 0 'False End Begin VB.Image imgNumber Appearance = 0 'Flat Height = 480 Index = 0 Left = 5400 Picture = "yatzy.frx":06F9 Top = 600 Width = 480 Visible = 0 'False End Begin VB.Menu mnuYatzy Caption = "&Spel" Begin VB.Menu mnuAbout Caption = "&Om" End Begin VB.Menu mnuHighScore Caption = "&High-Score" End Begin VB.Menu mnuNewGame Caption = "&Nytt-Spel" End Begin VB.Menu mnuSound Caption = "&Ljud" Checked = -1 'True End Begin VB.Menu mnuRestart Caption = "&Starta-Om (Ctrl+click)" End Begin VB.Menu mnuRegret Caption = "& ngra" End Begin VB.Menu mnuExit Caption = "&Avsluta" End End Attribute VB_Name = "frmYatzy" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False '------------------------------------------------------------------------- 'Code by: Anders Fransson 'Email: anders.fransson@home.se 'Internet: http://hem1.passagen.se/fylke 'Date: 97-07-25 '------------------------------------------------------------------------- Option Explicit Private msPlayer(4) As String 'Players name Private miBonusSum(4) As Integer 'Bonus sum for player Private miTotalSum(4) As Integer 'Total sum for player Private miOneToSix(4) As Integer 'Nr of clicks in the 1 to 6 rows for player Private miRoundSum As Integer 'Sum for a round Private miPlayer As Integer 'Index of player (1-5) Private miNrOfPlayers As Integer 'Nr of players (1-5) Private miThrows As Integer 'Nr of throws for a player (0-3) Private miThrowsIfRegret As Integer 'The last nr of throws for a player (1-3) Private miRound As Integer 'Round to play (0-10 if single player) Private miClickedRows As Integer 'Nr of clicked rows (0-15) for last player Private miLastClickedRow As Integer 'The last clicked row Private mbNewGame As Boolean 'True if new game is selected Public mbGameNotStarted As Boolean 'True if game not is started Const COLUMN_WIDTH As Integer = 420 Const MAX_PLAYERS As Integer = 5 Const DICE_MOVE As Integer = 150 'Text constants Const TEXT_HIT_DICES As String = "sl med t rningarna" Const TEXT_TWO_LEFT As String = "tv nger till" Const TEXT_ONE_LEFT As String = "en g ng till" Const TEXT_CLICK_SCORE_BOARD As String = "klicka p spelplanen" Const TEXT_ZERO_POINTS As String = "-" Const TEXT_RESTART As String = "Ctrl + click = starta om" Const TEXT_POINTS_BY As String = "po ng av" Const TEXT_CHEAT As String = "Fusk Fusk Fusk Fusk Fusk" 'Registry text constants Const TEXT_ANDERS_GAMES As String = "Anders Franssons Made In Home Games" Const TEXT_YATZY As String = "Yatzy" Const TEXT_PLAYER As String = "Player" Const TEXT_HIGH_SCORE As String = "High score" Private Static Sub Form_Load() Dim i% mbGameNotStarted = True 'Set grid size grdScoreBoard.ColWidth(0) = 1.9 * COLUMN_WIDTH For i = 1 To grdScoreBoard.Cols - 1 grdScoreBoard.ColWidth(i) = COLUMN_WIDTH Next Me.Show 'Initialize random number generator Randomize mbNewGame = True mnuRegret.Enabled = False NewGame mbGameNotStarted = False End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'New game if ctrl is pressed If Shift = vbCtrlMask Then mbNewGame = False NewGame End If End Sub Private Static Sub cmdHitMe_mouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim i%, iMaxThrows% iMaxThrows = 3 'If you really want to beat the high-score (Ctrl + Shift + Alt + RightClick) If Shift = 7 And Button = 2 And X < cmdHitMe.Left - 350 Then iMaxThrows = 100 cmdHitMe.Caption = TEXT_CHEAT End If 'New game if ctrl is pressed, else shuffle dices If Shift = vbCtrlMask Then NewGame Else If cmdHitMe.Caption = TEXT_RESTART Then Exit Sub mnuRegret.Enabled = False miThrows = miThrows + 1 miThrowsIfRegret = miThrows If miThrows <= iMaxThrows Then For i = 0 To 4 If picDice(i).Top > 150 Then _ picDice(i).Picture = imgNumber(Int(6 * Rnd)).Picture Next Timer1.Enabled = True End If End If End Sub Private Static Sub cmdHitMe_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim i%, j% If cmdHitMe.Caption = TEXT_RESTART Then Exit Sub If miThrows <= 3 Then j = 0 For i = 0 To 4 If picDice(i).Top > 150 Then j = j + 1 Next Select Case j Case 1: If mnuSound.Checked Then PlaySound App.Path & "\1.wav" Case 2, 3: If mnuSound.Checked Then PlaySound App.Path & "\2.wav" Case 4, 5: If mnuSound.Checked Then PlaySound App.Path & "\4.wav" End Select End If Select Case miThrows Case 1 cmdHitMe.Caption = msPlayer(miPlayer - 1) & ", " & TEXT_TWO_LEFT grdScoreBoard.Enabled = True For i = 0 To 4 picDice(i).Enabled = True Next Case 2 cmdHitMe.Caption = msPlayer(miPlayer - 1) & ", " & TEXT_ONE_LEFT Case Else cmdHitMe.Caption = msPlayer(miPlayer - 1) & ", " & TEXT_CLICK_SCORE_BOARD End Select 'Stop shuffling dices Timer1.Enabled = False End Sub Private Static Sub grdScoreBoard_Click() Dim i%, j%, iNumberCounter%, iPar%, iTriss% 'Exit if clicked cell not empty or if wrong player-column If Not grdScoreBoard.Text = "" Or Not grdScoreBoard.Col = _ miRound * miNrOfPlayers + miPlayer Then Exit Sub mnuRegret.Enabled = True miRoundSum = 0 miLastClickedRow = grdScoreBoard.Row Select Case grdScoreBoard.Row Case 0, 7, 8, 18 'Name, sum, bonus, total mnuRegret.Enabled = False Exit Sub Case 1, 2, 3, 4, 5, 6 miOneToSix(miPlayer - 1) = miOneToSix(miPlayer - 1) + 1 For i = 0 To 4 If picDice(i).Picture = _ imgNumber(grdScoreBoard.Row - 1).Picture Then miRoundSum = miRoundSum + grdScoreBoard.Row End If Next 'Bonus sum miBonusSum(miPlayer - 1) = miBonusSum(miPlayer - 1) + miRoundSum 'Show bonus-sum if round sum > 0 If Not miRoundSum = 0 Then grdScoreBoard.Row = 7 If Not miBonusSum(miPlayer - 1) = 0 Then _ grdScoreBoard.Text = miBonusSum(miPlayer - 1) End If 'Check if bonus If miBonusSum(miPlayer - 1) >= 63 Then grdScoreBoard.Row = 8 If Not grdScoreBoard.Text = "50" Then grdScoreBoard.Text = 50 miTotalSum(miPlayer - 1) = miTotalSum(miPlayer - 1) + 50 End If Else If miOneToSix(miPlayer - 1) = 6 Then grdScoreBoard.Row = 8 grdScoreBoard.Text = TEXT_ZERO_POINTS End If End If grdScoreBoard.Row = miLastClickedRow Case 9 'Ett-par miRoundSum = 0 For i = 5 To 0 Step -1 iNumberCounter = 0 For j = 0 To 4 If picDice(j).Picture = imgNumber(i).Picture Then _ iNumberCounter = iNumberCounter + 1 Next If iNumberCounter >= 2 Then miRoundSum = (i + 1) * 2 Exit For End If Next Case 10 'Tv miRoundSum = 0 iPar = 0 For i = 0 To 5 iNumberCounter = 0 For j = 0 To 4 If picDice(j).Picture = imgNumber(i).Picture Then _ iNumberCounter = iNumberCounter + 1 Next If iPar = 1 And iNumberCounter >= 2 Then miRoundSum = miRoundSum + (i + 1) * 2 iPar = iPar + 1 End If If iPar = 0 And iNumberCounter >= 2 Then miRoundSum = miRoundSum + (i + 1) * 2 iPar = iPar + 1 End If Next If iPar < 2 Then miRoundSum = 0 Case 11 'Triss miRoundSum = 0 For i = 0 To 5 iNumberCounter = 0 For j = 0 To 4 If picDice(j).Picture = imgNumber(i).Picture Then _ iNumberCounter = iNumberCounter + 1 Next If iNumberCounter >= 3 Then miRoundSum = (i + 1) * 3 Exit For End If Next Case 12 'Fyrtal miRoundSum = 0 For i = 0 To 5 iNumberCounter = 0 For j = 0 To 4 If picDice(j).Picture = imgNumber(i).Picture Then _ iNumberCounter = iNumberCounter + 1 Next If iNumberCounter >= 4 Then miRoundSum = (i + 1) * 4 Exit For End If Next Case 13 'Liten stege miRoundSum = 15 For i = 0 To 4 For j = 0 To 4 If Not i = j Then If picDice(i).Picture = picDice(j).Picture Or _ picDice(i).Picture = imgNumber(5).Picture Then _ miRoundSum = 0 End If Next Next Case 14 'Stor stege miRoundSum = 20 For i = 0 To 4 For j = 0 To 4 If Not i = j Then If picDice(i).Picture = picDice(j).Picture Or _ picDice(i).Picture = imgNumber(0).Picture Then _ miRoundSum = 0 End If Next Next Case 15 'K miRoundSum = 0 iPar = False iTriss = False For i = 0 To 5 iNumberCounter = 0 For j = 0 To 4 If picDice(j).Picture = imgNumber(i).Picture Then _ iNumberCounter = iNumberCounter + 1 Next If iNumberCounter = 2 Then miRoundSum = miRoundSum + (i + 1) * 2 iPar = True End If If iNumberCounter = 3 Then miRoundSum = miRoundSum + (i + 1) * 3 iTriss = True End If Next If Not iPar Or Not iTriss Then miRoundSum = 0 Case 16 'Chans For i = 0 To 4 For j = 0 To 5 If picDice(i).Picture = imgNumber(j).Picture Then _ miRoundSum = miRoundSum + j + 1 Next Next Case 17 'Yatzy If mnuSound.Checked Then PlaySound App.Path & "\Applause.wav" miRoundSum = 50 For i = 1 To 4 If Not picDice(i).Picture = picDice(0).Picture Then miRoundSum = 0 Next End Select 'Show round-sum If miRoundSum = 0 Then If mnuSound.Checked Then PlaySound App.Path & "\Boo.wav" grdScoreBoard.Text = TEXT_ZERO_POINTS Else grdScoreBoard.Text = miRoundSum End If 'Show total-sum if round sum > 0 If Not miRoundSum = 0 Then grdScoreBoard.Row = 18 miTotalSum(miPlayer - 1) = miTotalSum(miPlayer - 1) + miRoundSum grdScoreBoard.Text = miTotalSum(miPlayer - 1) End If 'If last player then increase nr of clicked rows If miPlayer = miNrOfPlayers Then miClickedRows = miClickedRows + 1 'If all rows are clicked for the match If miClickedRows = grdScoreBoard.Rows - 4 Then mnuRegret.Enabled = False miRound = miRound + 1 miClickedRows = 0 CheckIfHighScore 'Reset players sum For i = 1 To miNrOfPlayers miTotalSum(i - 1) = 0 miBonusSum(i - 1) = 0 miOneToSix(i - 1) = 0 Next 'If score board is full If (miRound + 1) * miNrOfPlayers > 10 Then miRound = 0 cmdHitMe.Caption = TEXT_RESTART Exit Sub Else WritePlayers End If End If NextPlayer End Sub Private Sub grdScoreBoard_MouseDown(Button As Integer, Shift As Integer, _ X As Single, Y As Single) 'New game if ctrl is pressed If Shift = vbCtrlMask Then mbNewGame = False NewGame End If End Sub Private Sub mnuAbout_Click() frmAbout.ShowAboutForm TEXT_YATZY, imgNumber(0) End Sub Private Sub mnuExit_Click() Unload Me End End Sub Private Sub mnuHighScore_Click() 'Get high score from registry and show it in a msgbox MsgBox GetSetting(TEXT_ANDERS_GAMES, TEXT_YATZY, TEXT_HIGH_SCORE, 0) _ & " " & TEXT_POINTS_BY & " " & _ GetSetting(TEXT_ANDERS_GAMES, TEXT_YATZY, TEXT_PLAYER, "?"), _ vbOKOnly, TEXT_HIGH_SCORE End Sub Private Sub mnuNewGame_Click() mbNewGame = True NewGame End Sub Private Sub mnuRestart_Click() mbNewGame = False NewGame End Sub Private Static Sub mnuRegret_Click() Dim i% 'Enable dices again For i = 0 To 4 picDice(i).Enabled = True Next 'Disable the regret menu mnuRegret.Enabled = False 'Update some index miThrows = miThrowsIfRegret miPlayer = miPlayer - 1 If miPlayer < 1 Then miPlayer = miNrOfPlayers If miPlayer = miNrOfPlayers Then miClickedRows = miClickedRows - 1 'Update the command button caption If miThrows = 1 Then _ cmdHitMe.Caption = msPlayer(miPlayer - 1) & ", " & TEXT_TWO_LEFT If miThrows = 2 Then _ cmdHitMe.Caption = msPlayer(miPlayer - 1) & ", " & TEXT_ONE_LEFT If miThrows >= 3 Then _ cmdHitMe.Caption = msPlayer(miPlayer - 1) & ", " & TEXT_CLICK_SCORE_BOARD 'Clear the last clicked cell grdScoreBoard.Enabled = True grdScoreBoard.Row = miLastClickedRow grdScoreBoard.Text = "" 'Update bonus If miLastClickedRow < 7 Then miOneToSix(miPlayer - 1) = miOneToSix(miPlayer - 1) - 1 grdScoreBoard.Row = 7 miBonusSum(miPlayer - 1) = miBonusSum(miPlayer - 1) - miRoundSum If miBonusSum(miPlayer - 1) = 0 Then grdScoreBoard.Text = "" Else grdScoreBoard.Text = miBonusSum(miPlayer - 1) End If If miBonusSum(miPlayer - 1) < 63 Then grdScoreBoard.Row = 8 If grdScoreBoard.Text = "50" Then miTotalSum(miPlayer - 1) = miTotalSum(miPlayer - 1) - 50 End If grdScoreBoard.Text = "" End If End If 'Update total sum grdScoreBoard.Row = 18 miTotalSum(miPlayer - 1) = miTotalSum(miPlayer - 1) - miRoundSum If miTotalSum(miPlayer - 1) = 0 Then grdScoreBoard.Text = "" Else grdScoreBoard.Text = miTotalSum(miPlayer - 1) End If End Sub Private Sub mnuSound_Click() mnuSound.Checked = Not mnuSound.Checked End Sub Private Sub picDice_MouseDown(Index As Integer, Button As Integer, _ Shift As Integer, X As Single, Y As Single) 'Move dice up or down If picDice(Index).Top > 150 Then picDice(Index).Top = picDice(Index).Top - DICE_MOVE Else picDice(Index).Top = picDice(Index).Top + DICE_MOVE End If End Sub Private Static Sub Timer1_Timer() Dim i% 'Shuffle dices For i = 0 To 4 If picDice(i).Top > 150 Then picDice(i).Picture = imgNumber(Int(6 * Rnd)).Picture Next End Sub Private Static Sub CheckIfHighScore() Dim i% 'Loop players and check if high score For i = 1 To miNrOfPlayers If miTotalSum(i - 1) > GetSetting(TEXT_ANDERS_GAMES, TEXT_YATZY, TEXT_HIGH_SCORE, 0) Then SaveSetting TEXT_ANDERS_GAMES, TEXT_YATZY, TEXT_HIGH_SCORE, miTotalSum(i - 1) SaveSetting TEXT_ANDERS_GAMES, TEXT_YATZY, TEXT_PLAYER, msPlayer(i - 1) End If Next End Sub Private Static Sub NewGame() Dim i%, j%, iTempNrOfPlayers% Dim sTempPlayer(4) As String Dim strYatzyText As Variant strYatzyText = Array("YATZY", "Ettor", "Tv or", "Treor", "Fyror", _ "Femmor", "Sexor", "Summa", "Bonus", "Par", "Tv par", "Triss", _ "Fyrtal", "l-stege", "s-stege", "K k", "Chans", "Yatzy", "Summa") 'If new game then input players If mbNewGame Then 'Input nr of players iTempNrOfPlayers = Val(frmInput.ShowInputForm(Me)) If iTempNrOfPlayers = -1 Then Exit Sub 'Input player names For i = 1 To iTempNrOfPlayers sTempPlayer(i - 1) = frmInput.ShowInputForm(Me, i) If sTempPlayer(i - 1) = "-1" Then Exit Sub Next i 'If not cancel miNrOfPlayers = iTempNrOfPlayers For i = 1 To miNrOfPlayers msPlayer(i - 1) = sTempPlayer(i - 1) Next i End If Me.Refresh miPlayer = 0 miRound = 0 miClickedRows = 0 'Reset players sum For i = 0 To MAX_PLAYERS - 1 miTotalSum(i) = 0 miBonusSum(i) = 0 miOneToSix(i) = 0 Next 'Show random dices For i = 0 To 4 picDice(i).Picture = imgNumber(Int(6 * Rnd)).Picture Next 'Clear grid and write text in first column grdScoreBoard.Clear grdScoreBoard.Col = 0 grdScoreBoard.FontBold = True For i = 0 To grdScoreBoard.Rows - 1 grdScoreBoard.Row = i grdScoreBoard.Text = strYatzyText(i) Next mnuRegret.Enabled = False mbNewGame = False WritePlayers NextPlayer End Sub Private Static Sub NextPlayer() Dim i% miThrows = 0 'Change player miPlayer = miPlayer + 1 If miPlayer = miNrOfPlayers + 1 Then miPlayer = 1 cmdHitMe.Caption = msPlayer(miPlayer - 1) & ", " & TEXT_HIT_DICES 'Disable and place dices grdScoreBoard.Enabled = False For i = 0 To 4 picDice(i).Enabled = False If picDice(i).Top < 150 Then picDice(i).Top = picDice(i).Top + DICE_MOVE Next End Sub Private Static Sub WritePlayers() Dim i% 'Write player names in 1:st row grdScoreBoard.Row = 0 For i = 1 To miNrOfPlayers grdScoreBoard.Col = miRound * miNrOfPlayers + i grdScoreBoard.Text = msPlayer(i - 1) Next End Sub